Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Module source / Extrasmod.txt < prev next >

Wrap

Text File | 1995-11-26 | 12.4 KB | 546 lines | [TEXT/MSET]

\ This module implements a number of words that we need only at compile time, \ or only in the Mops development environment. \ ======== Display of source code ======== \ The display is rather crude, but at least you can see the source. \ If AppleEvents are available, we do a lot better and send an AE to \ Quick Edit to open the file at the given position, and then we don't \ use the display code here. (And good riddance, too.) false value LOG_THERE? false value SRC_THERE? false value USE_MOD? false value QE? :class FSSpec super{ object } record { int vRefNum var parID 64 bytes filename } :m getVref: get: vRefNum ;m :m getDirID: get: parID ;m :m setVref: put: vRefNum ;m :m setDirID: put: parID ;m :m name: 64 min addr: fileName >str255 drop ;m :m getName: addr: fileName count ;m :m NEW: word0 int: vRefNum get: parID addr: filename ^base call FSMakeFSSpec i->l ;m ;class FSSpec FS objPtr THEMOD class_is module window DW file LOG file SRC file QEF string+ DSP string+ S string+ $TMP string+ $LOG string+ $PRF 0 value CURS_POS 0 value CURS_ROW 0 value CURS_COL 0 value MK_CFA 0 value TOPDIR 0 value TOPDATE : OPEN_SRC_WINDOW QE? ?EXIT \ If we're showing the source in QE, out s copyto: dsp 2 38 494 170 put: tempRect tempRect " " docWind true true new: dw screenbits true setGrow: dw setFwind true -> src_there? ; : SET_DSP { \ cr? -- } true -> cr? s copyto: dsp curs_pos >pos: dsp 2 0 DO <nextline?: dsp NIF LEAVE THEN LOOP pos: dsp 10 0 ?DO nextline?: dsp NIF false -> cr? LEAVE THEN LOOP >pos: dsp cr? more: dsp ; local DISPLAY { disp? \ redraw? end_disp curs_line_pos 1st? -- } : (DISP) 0 -> curs_row 0 -> curs_line_pos true -> 1st? disp? IF 4 tFont 9 tSize -curs cls THEN \ Monaco 9 BEGIN nextline?: dsp 0EXIT lim: dsp end_disp > ?EXIT 1st? IF false -> 1st? ELSE disp? IF cr THEN THEN lim: dsp curs_pos < IF 1 ++> curs_row lim: dsp 1+ -> curs_line_pos THEN disp? IF get: dsp type THEN AGAIN ; : SHOW_CURS +curs disp? NIF .cur THEN \ If just updating, erase curs curs_pos curs_line_pos - dup -> curs_col 1+ 6 * \ x curs_row 1+ #lead * 6 + \ y gotoxy .cur ; : (DISPLAY) lim: dsp -> end_disp save: dsp 0 >len: dsp (disp) restore: dsp ; :loc DISPLAY \ { disp? \ redraw? end_disp curs_line_pos 1st? -- } QE? IF qef curs_pos dup openFile: tQE 0EXIT false -> QE? \ failed - assume QE has gone away open_src_window THEN src_there? 0EXIT pushPort set: dw (display) curs_row 0= pos: dsp 0<> and -> redraw? curs_row 6 > lim: dsp size: dsp < and --> redraw? redraw? IF set_dsp update: dw THEN show_curs popPort ;loc ' redraw setdraw: dw \ Note: this must refer to the EXPORTED \ version of redraw. : REDRAW true display ; : UPD false display ; : 1UP curs_pos 1- 0 max dup >pos: s >lim: s <nextline?: s 0EXIT pos: s dup IF 1+ THEN -> curs_pos upd ; : 1DN curs_pos dup >pos: s >lim: s nextline?: s 0EXIT lim: s 1+ -> curs_pos upd ; : 1LFT ; \ Really not much point in implementing these! : 1RT ; : HOMEx 0 -> curs_pos upd ; : END size: s -> curs_pos upd ; : DEFNUP { \ posn -- } curs_pos 1- 0 max dup >pos: s >lim: s BEGIN <nextline?: s 0EXIT pos: s -> posn posn IF 1 ++> posn THEN ptr: s posn + c@ & : = IF posn -> curs_pos upd EXIT THEN AGAIN ; : DEFNDN curs_pos dup >pos: s >lim: s BEGIN nextline?: s 0EXIT ^1st: s 1+ c@ & : = IF pos: s 1+ -> curs_pos upd EXIT THEN AGAIN ; \ ADDR>CURS is exported. It takes a dictionary address, and tries to \ convert it to the corresponding "cursor" position in the source file. \ If we have a source window open, it updates the cursor position in \ that window as well. : ADDR>CURS { addr \ offs -- curs-pos } log_there? NIF 0 EXIT THEN addr filestart_dp - -> addr 0 -> offs reset: $log BEGIN len: $log 0<= IF 0 EXIT THEN ^1st: $log w@ addr > IF ( found ) offs -> curs_pos upd offs EXIT THEN ^1st: $log 2+ @ -> offs 6 skip: $log AGAIN ; : MOVE_CURS \ ( pos -- ) Exported. -> curs_pos upd ; : SELECTDW \ Exported. src_there? 0EXIT select: dw ; : CHK_DATE getFileInfo: src OK? src 76 + @ use_mod? IF base: theMod @ ELSE mk_cfa 6 + @ ?dup NIF -1 THEN THEN u> IF 3 beep cr msg# 76 \ "Source later than compiled version" THEN ; \ ?OPEN_IN_QE is exported. It sees if the passed-in file can be opened \ in Quick Edit via an AppleEvent. The value QE? is left indicating \ the result. It's not a serious problem if we can't find the file, but \ it's nice if we can. : ?OPEN_IN_QE { ^file -- } false -> QE? AppleEvents? 0EXIT getname: [ ^file ] name: FS 0 setVref: FS 0 setDirID: FS new: FS IF \ An error occured. The file might have been opened via \ standard file. In this case, topDir will be set. Let's \ try... getName: [ ^file ] name: FS 0 setVref: FS topDir setDirID: FS new: fs ?EXIT \ Out if we still can't find it THEN getName: FS name: qef getVref: FS setVref: qef getDirID: FS setDirID: qef qef 0 0 openFile: tQE ?EXIT \ If AE send failed, maybe QE isn't there at all! true -> QE? ; : (OPEN_SRC) 2dup put: $tmp name: src use_mod? NIF mk_cfa @ setDirID: src THEN openReadOnly: src ?EXIT \ Out on error chk_date src readAll: s \ read source - we do this even if we can close: src drop \ open it in QE, since we might need it for \ PROFILE or something src ?open_in_QE QE? ?EXIT open_src_window get: $tmp title: dw 0 -> curs_pos set_dsp update: dw ; : SRC_NAME mk_cfa >name n>count 1- ; : OPEN_SRC src_name (open_src) ; : OPEN_SRC_IN_MOD txtName: theMod (open_src) ; \ The following words are used in conjunction with Quick Edit. \ EDIT is exported. It opens the given file in QE if possible. \ Usage: edit xxxx : EDIT setName: src openReadOnly: src \ Get full pathname. ?error 66 \ "couldn't find source file" src ?open_in_QE close: src drop QE? not ?error 67 \ "Quick Edit not open or sys7 not running" ; \ OPENSOURCE is exported. This word is called from QE, so we can assume \ QE is there. QE is asking us to identify the source file for the given \ word, and then call QE back to open that file. The format of the string \ sent from QE (located in QEstr) is FindSource xxxxx. At this point \ we're EVALUATEing, and have parsed the FindSource, so we can now \ simply call DEFINED?. \ Note: this word is also called LOCATE, which I now think is a better name. : OPENSOURCE defined? IF locate_src ELSE 1 beep reset: QEstr 11 skip: QEstr \ skip over OpenSource get: QEstr type space ." not defined!!" THEN ; \ def?? is exported. It's needed by the QE special menu item def?? : def?? \ 19Dec93 DBH slightly changed to show us the word in question and \ display the answer reset: QEstr 6 skip: QEstr \ skip over def?? get: QEstr type space defined? nip IF ." defined" ELSE ." not defined!!" THEN ; \ ========== end of QE-related words ============= : (CREATE_LOG) here -> filestart_dp new: $lg1 new: $lg2 $ B3010000 pad ! \ Unique marker for log files | version false -> relocChk? here pad 4+ reloc! true -> relocChk? pad 8 put: $lg1 ; : (WRITE_LOG) \ Called to write out the log and profile strings to the \ 2 corresponding files getname: topfile put: $tmp " .log" add: $tmp all: $tmp name: log use_mod? IF 0 ELSE topDir THEN setDirID: log \ OK to use zero for modules, since the module's source \ file name will be fully qualified. create: log ?dup IF . space ." I/O err creating log file " abort THEN 0 setDirID: log 'type SLOG 'type MOPS set: log reset: $lg1 len: $lg1 ^1st: $lg1 2+ w! all: $lg1 write: log OK? all: $lg2 write: log OK? close: log OK? release: $lg1 release: $lg2 ; : OPEN_LOG \ Exported (for error handling) false -> log_there? clear: $log clear: $prf use_mod? IF " .txt.log" extname: theMod put: $tmp all: $tmp name: log \ base: theMod 4+ @ setDirID: log ELSE mk_cfa 4+ w@ NIF ( No log file ) clear: $log EXIT THEN " .log" add: $tmp all: $tmp name: log 0 setVref: log mk_cfa @ setDirID: log THEN openReadOnly: log ?EXIT \ If error, maybe log not there. pad 8 read: log OK? pad w@ $ B301 = 0EXIT \ Out if not valid log file true -> log_there? use_mod? IF base: theMod #imp: theMod 2* + 8 + ELSE pad 4+ @abs THEN -> filestart_dp log pad 2+ w@ 8 - readN: $log log readRest: $prf close: log drop \ rd: $log rd: $prf \ set: fwind dump: $log set: dw \ debugging only src_there? IF redraw THEN true -> log_there? ; : CL \ Close src and log etc. src_there? 0EXIT close: dw release: s release: $tmp release: $log release: $prf close: src drop false -> log_there? false -> src_there? false -> QE? setFwind drop: extrasmod ; : (FINDMK) \ ( cfa 0 -- ) drop dup -> mk_cfa 2- w@x file-mark = -> endTrav? ; : FIND_MARK? \ ( start-addr -- ) ['] (findmk) 0 rot trav-from endTrav? ; : LOCATE_SRC { theCfa -- } \ Exported. Opens source window for given \ definition, if possible. lock: extrasmod \ Since we have a window, and windows \ mustn't move! use_mod? NIF theCfa find_mark? NIF src_there? IF cl THEN EXIT THEN THEN use_mod? IF open_src_in_mod open_log false -> use_mod? \ For next time ELSE open_src open_log THEN QE? IF theCfa >name n>count find: tQE drop THEN ; : USE_MODULE \ ( ^mod -- ) -> theMod true -> use_mod? ; : PROF_STR \ Exported - called by DebugMod to get hold of the profile \ string and source string. reset: $prf reset: s $prf s ; \ ======== Code for loading and reloading ========= : PURGE_INIT_ACTIONS { \ index -- } \ We call this before reloading, to get rid of any \ invalid entries out of INIT_ACTIONS. 0 -> index BEGIN index size: init_actions >= ?EXIT index ^elem: init_actions @abs here u> IF index remove: init_actions ELSE 1 ++> index THEN AGAIN ; : <CS { addr len c \ offs -- addr len offs } len -> offs addr addr len + 1- DO i c@ c = IF LEAVE THEN -1 ++> offs -1 +LOOP addr len offs ; : +LOG true -> log? ; : -LOG false -> log? ; : SAVE-LOAD getName: topFile put: $tmp bl +: $tmp reset: $tmp & : <chsearch: $tmp negate skip: $tmp get: $tmp sHdr file-mark w, topDir , log? w, topDate , release: $tmp ; : LOADIT { \ svCurs -- } watchcurs purge_init_actions curs -> svCurs -curs getFileInfo: topFile NIF topFile 76 + @ ELSE 0 THEN -> topDate clear: topFile topDir setDirID: topFile save-load MBcomp LdFromMod drop: loadFile \ log? IF -log THEN svCurs -> curs arrowcurs ; : L \ Load pushNew: loadfile 'type TEXT 1 stdget: topfile IF getDirID dup setDirID: topFile -> topDir loadit ELSE clear: loadfile THEN ; : FM \ Forget to mark here find_mark? not abort" No mark!" mk_cfa >link (forget) ; : RL here find_mark? not abort" L not done!" cl \ Close source window if open as it probably \ won't be valid any more. pushnew: loadfile src_name name: topFile mk_cfa @ dup -> topDir setDirID: topFile \ mk_cfa 4+ w@x ++> log? mk_cfa >link (forget) loadit ; \ Put NEED XXX at the start of a file that requires XXX to be already \ loaded. If the word XXX is not defined, a file of that name is loaded. \ Note that only one blank or tab is allowed between NEED and the ilename. \ This is because we use WORD" to read the ilename, so that names with \ embedded blanks are allowed. : NEED { \ svLog svTopDir svTopDate -- } word" count \ Get name from input put: $tmp bl +: $tmp reset: $tmp & : <chsearch: $tmp negate skip: $tmp get: $tmp sFind nip IF release: $tmp EXIT THEN \ Found - nothing else to do \ Not found - load it latest name> 2- w@x file-mark = IF \ That was a file-mark - forget it so RL \ won't make us reload NEEDed files latest n>link (forget) THEN pushnew: loadFile get: $tmp 1- name: topfile release: $tmp log? -> svLog -log \ Don't log NEEDed file openReadOnly: topFile ?file_open_error close: topFile drop getFileInfo: topFile ?file_open_error topDate -> svTopDate topDir -> svTopDir \ getDirID: topFile -> topDir \ I'm not too sure why this doesn't work 0 -> topDir clear: topFile \ Leaves name field intact loadit \ Load NEEDed file svLog IF +log THEN svTopDate -> topDate svTopDir -> topDir size: loadFile IF save-load THEN ; ' cl setrelease